home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 3: Developer Tools / Linux Cubed Series 3 - Developer Tools.iso / devel / lang / fortran / f2c-9510.000 / f2c-9510 / f2c-951007-libs-1.1 / src / names.c < prev    next >
Encoding:
C/C++ Source or Header  |  1995-10-07  |  20.7 KB  |  823 lines
  1. /****************************************************************
  2. Copyright 1990, 1992 - 1995 by AT&T Bell Laboratories and Bellcore.
  3.  
  4. Permission to use, copy, modify, and distribute this software
  5. and its documentation for any purpose and without fee is hereby
  6. granted, provided that the above copyright notice appear in all
  7. copies and that both that the copyright notice and this
  8. permission notice and warranty disclaimer appear in supporting
  9. documentation, and that the names of AT&T Bell Laboratories or
  10. Bellcore or any of their entities not be used in advertising or
  11. publicity pertaining to distribution of the software without
  12. specific, written prior permission.
  13.  
  14. AT&T and Bellcore disclaim all warranties with regard to this
  15. software, including all implied warranties of merchantability
  16. and fitness.  In no event shall AT&T or Bellcore be liable for
  17. any special, indirect or consequential damages or any damages
  18. whatsoever resulting from loss of use, data or profits, whether
  19. in an action of contract, negligence or other tortious action,
  20. arising out of or in connection with the use or performance of
  21. this software.
  22. ****************************************************************/
  23.  
  24. #include "defs.h"
  25. #include "output.h"
  26. #include "names.h"
  27. #include "iob.h"
  28.  
  29.  
  30. /* Names generated by the translator are guaranteed to be unique from the
  31.    Fortan names because Fortran does not allow underscores in identifiers,
  32.    and all of the system generated names do have underscores.  The various
  33.    naming conventions are outlined below:
  34.  
  35.     FORMAT        APPLICATION
  36.    ----------------------------------------------------------------------
  37.     io_#        temporaries generated by IO calls; these will
  38.             contain the device number (e.g. 5, 6, 0)
  39.     ret_val        function return value, required for complex and
  40.             character functions.
  41.     ret_val_len    length of the return value in character functions
  42.  
  43.     ssss_len    length of character argument "ssss"
  44.  
  45.     c_#        member of the literal pool, where # is an
  46.             arbitrary label assigned by the system
  47.     cs_#        short integer constant in the literal pool
  48.     t_#        expression temporary, # is the depth of arguments
  49.             on the stack.
  50.     L#        label "#", given by user in the Fortran program.
  51.             This is unique because Fortran labels are numeric
  52.     pad_#        label on an init field required for alignment
  53.     xxx_init    label on a common block union, if a block data
  54.             requires a separate declaration
  55. */
  56.  
  57. /* generate variable references */
  58.  
  59.  char *
  60. #ifdef KR_headers
  61. c_type_decl(type, is_extern)
  62.     int type;
  63.     int is_extern;
  64. #else
  65. c_type_decl(int type, int is_extern)
  66. #endif
  67. {
  68.     static char buff[100];
  69.  
  70.     switch (type) {
  71.     case TYREAL:    if (!is_extern || !forcedouble)
  72.                 { strcpy (buff, "real");break; }
  73.     case TYDREAL:    strcpy (buff, "doublereal");    break;
  74.     case TYCOMPLEX:    if (is_extern)
  75.                 strcpy (buff, "/* Complex */ VOID");
  76.             else
  77.                 strcpy (buff, "complex");
  78.             break;
  79.     case TYDCOMPLEX:if (is_extern)
  80.                 strcpy (buff, "/* Double Complex */ VOID");
  81.             else
  82.                 strcpy (buff, "doublecomplex");
  83.             break;
  84.     case TYADDR:
  85.     case TYINT1:
  86.     case TYSHORT:
  87.     case TYLONG:
  88. #ifdef TYQUAD
  89.     case TYQUAD:
  90. #endif
  91.     case TYLOGICAL1:
  92.     case TYLOGICAL2:
  93.     case TYLOGICAL:    strcpy(buff, typename[type]);
  94.             break;
  95.     case TYCHAR:    if (is_extern)
  96.                 strcpy (buff, "/* Character */ VOID");
  97.             else
  98.                 strcpy (buff, "char");
  99.             break;
  100.  
  101.         case TYUNKNOWN:    strcpy (buff, "UNKNOWN");
  102.  
  103. /* If a procedure's type is unknown, assume it's a subroutine */
  104.  
  105.             if (!is_extern)
  106.                 break;
  107.  
  108. /* Subroutines must return an INT, because they might return a label
  109.    value.  Even if one doesn't, the caller will EXPECT it to. */
  110.  
  111.     case TYSUBR:    strcpy (buff, "/* Subroutine */ int");
  112.                             break;
  113.     case TYERROR:    strcpy (buff, "ERROR");        break;
  114.     case TYVOID:    strcpy (buff, "void");        break;
  115.     case TYCILIST:    strcpy (buff, "cilist");    break;
  116.     case TYICILIST:    strcpy (buff, "icilist");    break;
  117.     case TYOLIST:    strcpy (buff, "olist");        break;
  118.     case TYCLLIST:    strcpy (buff, "cllist");    break;
  119.     case TYALIST:    strcpy (buff, "alist");        break;
  120.     case TYINLIST:    strcpy (buff, "inlist");    break;
  121.     case TYFTNLEN:    strcpy (buff, "ftnlen");    break;
  122.     default:    sprintf (buff, "BAD DECL '%d'", type);
  123.                             break;
  124.     } /* switch */
  125.  
  126.     return buff;
  127. } /* c_type_decl */
  128.  
  129.  
  130.  char *
  131. new_func_length(Void)
  132. { return "ret_val_len"; }
  133.  
  134.  char *
  135. #ifdef KR_headers
  136. new_arg_length(arg)
  137.     Namep arg;
  138. #else
  139. new_arg_length(Namep arg)
  140. #endif
  141. {
  142.     static char buf[64];
  143.     sprintf (buf, "%s_len", arg->fvarname);
  144.  
  145.     return buf;
  146. } /* new_arg_length */
  147.  
  148.  
  149. /* declare_new_addr -- Add a new local variable to the function, given a
  150.    pointer to an Addrblock structure (which must have the uname_tag set)
  151.    This list of idents will be printed in reverse (i.e., chronological)
  152.    order */
  153.  
  154.  void
  155. #ifdef KR_headers
  156. declare_new_addr(addrp)
  157.     struct Addrblock *addrp;
  158. #else
  159. declare_new_addr(struct Addrblock *addrp)
  160. #endif
  161. {
  162.     extern chainp new_vars;
  163.  
  164.     new_vars = mkchain((char *)cpexpr((expptr)addrp), new_vars);
  165. } /* declare_new_addr */
  166.  
  167.  
  168.  void
  169. #ifdef KR_headers
  170. wr_nv_ident_help(outfile, addrp)
  171.     FILE *outfile;
  172.     struct Addrblock *addrp;
  173. #else
  174. wr_nv_ident_help(FILE *outfile, struct Addrblock *addrp)
  175. #endif
  176. {
  177.     int eltcount = 0;
  178.  
  179.     if (addrp == (struct Addrblock *) NULL)
  180.     return;
  181.  
  182.     if (addrp -> isarray) {
  183.     frexpr (addrp -> memoffset);
  184.     addrp -> memoffset = ICON(0);
  185.     eltcount = addrp -> ntempelt;
  186.     addrp -> ntempelt = 0;
  187.     addrp -> isarray = 0;
  188.     } /* if */
  189.     out_addr (outfile, addrp);
  190.     if (eltcount)
  191.     nice_printf (outfile, "[%d]", eltcount);
  192. } /* wr_nv_ident_help */
  193.  
  194.  int
  195. #ifdef KR_headers
  196. nv_type_help(addrp)
  197.     struct Addrblock *addrp;
  198. #else
  199. nv_type_help(struct Addrblock *addrp)
  200. #endif
  201. {
  202.     if (addrp == (struct Addrblock *) NULL)
  203.     return -1;
  204.  
  205.     return addrp -> vtype;
  206. } /* nv_type_help */
  207.  
  208.  
  209. /* lit_name -- returns a unique identifier for the given literal.  Make
  210.    the label useful, when possible.  For example:
  211.  
  212.     1 -> c_1        (constant 1)
  213.     2 -> c_2        (constant 2)
  214.     1000 -> c_1000        (constant 1000)
  215.     1000000 -> c_b<memno>    (big constant number)
  216.     1.2 -> c_1_2        (constant 1.2)
  217.     1.234345 -> c_b<memno>    (big constant number)
  218.     -1 -> c_n1        (constant -1)
  219.     -1.0 -> c_n1_0        (constant -1.0)
  220.     .true. -> c_true    (constant true)
  221.     .false. -> c_false    (constant false)
  222.     default -> c_b<memno>    (default label)
  223. */
  224.  
  225.  char *
  226. #ifdef KR_headers
  227. lit_name(litp)
  228.     struct Literal *litp;
  229. #else
  230. lit_name(struct Literal *litp)
  231. #endif
  232. {
  233.     static char buf[CONST_IDENT_MAX];
  234.     ftnint val;
  235.     char *fmt;
  236.  
  237.     if (litp == (struct Literal *) NULL)
  238.         return NULL;
  239.  
  240.     switch (litp -> littype) {
  241.     case TYINT1:
  242.         val = litp -> litval.litival;
  243.         if (val >= 256 || val < -255)
  244.             sprintf (buf, "ci1_b%d", litp -> litnum);
  245.         else if (val < 0)
  246.             sprintf (buf, "ci1_n%ld", -val);
  247.         else
  248.             sprintf(buf, "ci1__%ld", val);
  249.         break;
  250.         case TYSHORT:
  251.         val = litp -> litval.litival;
  252.         if (val >= 32768 || val <= -32769)
  253.             sprintf (buf, "cs_b%d", litp -> litnum);
  254.         else if (val < 0)
  255.             sprintf (buf, "cs_n%ld", -val);
  256.         else
  257.             sprintf (buf, "cs__%ld", val);
  258.         break;
  259.     case TYLONG:
  260. #ifdef TYQUAD
  261.     case TYQUAD:
  262. #endif
  263.         val = litp -> litval.litival;
  264.         if (val >= 100000 || val <= -10000)
  265.             sprintf (buf, "c_b%d", litp -> litnum);
  266.         else if (val < 0)
  267.             sprintf (buf, "c_n%ld", -val);
  268.         else
  269.             sprintf (buf, "c__%ld", val);
  270.         break;
  271.     case TYLOGICAL1:
  272.         fmt = "cl1_%s";
  273.         goto spr_logical;
  274.     case TYLOGICAL2:
  275.         fmt = "cl2_%s";
  276.         goto spr_logical;
  277.     case TYLOGICAL:
  278.         fmt = "c_%s";
  279.     spr_logical:
  280.         sprintf (buf, fmt, (litp -> litval.litival
  281.                     ? "true" : "false"));
  282.         break;
  283.     case TYREAL:
  284.     case TYDREAL:
  285.         /* Given a limit of 6 or 8 character on external names,    */
  286.         /* few f.p. values can be meaningfully encoded in the    */
  287.         /* constant name.  Just going with the default cb_#    */
  288.         /* seems to be the best course for floating-point    */
  289.         /* constants.    */
  290.     case TYCHAR:
  291.         /* Shouldn't be any of these */
  292.     case TYADDR:
  293.     case TYCOMPLEX:
  294.     case TYDCOMPLEX:
  295.     case TYSUBR:
  296.     default:
  297.         sprintf (buf, "c_b%d", litp -> litnum);
  298.     } /* switch */
  299.     return buf;
  300. } /* lit_name */
  301.  
  302.  
  303.  
  304.  char *
  305. #ifdef KR_headers
  306. comm_union_name(count)
  307.     int count;
  308. #else
  309. comm_union_name(int count)
  310. #endif
  311. {
  312.     static char buf[12];
  313.  
  314.     sprintf(buf, "%d", count);
  315.     return buf;
  316.     }
  317.  
  318.  
  319.  
  320.  
  321. /* wr_globals -- after every function has been translated, we need to
  322.    output the global declarations, such as the static table of constant
  323.    values */
  324.  
  325.  void
  326. #ifdef KR_headers
  327. wr_globals(outfile)
  328.     FILE *outfile;
  329. #else
  330. wr_globals(FILE *outfile)
  331. #endif
  332. {
  333.     struct Literal *litp, *lastlit;
  334.     extern int hsize;
  335.     char *litname;
  336.     int did_one, t;
  337.     struct Constblock cb;
  338.     ftnint x, y;
  339.  
  340.     if (nliterals == 0)
  341.     return;
  342.  
  343.     lastlit = litpool + nliterals;
  344.     did_one = 0;
  345.     for (litp = litpool; litp < lastlit; litp++) {
  346.     if (!litp->lituse)
  347.         continue;
  348.     litname = lit_name(litp);
  349.     if (!did_one) {
  350.         margin_printf(outfile, "/* Table of constant values */\n\n");
  351.         did_one = 1;
  352.         }
  353.     cb.vtype = litp->littype;
  354.     if (litp->littype == TYCHAR) {
  355.         x = litp->litval.litival2[0] + litp->litval.litival2[1];
  356.         if (y = x % hsize)
  357.             x += y = hsize - y;
  358.         nice_printf(outfile,
  359.             "static struct { %s fill; char val[%ld+1];", halign, x);
  360.         nice_printf(outfile, " char fill2[%ld];", hsize - 1);
  361.         nice_printf(outfile, " } %s_st = { 0,", litname);
  362.         cb.vleng = ICON(litp->litval.litival2[0]);
  363.         cb.Const.ccp = litp->cds[0];
  364.         cb.Const.ccp1.blanks = litp->litval.litival2[1] + y;
  365.         cb.vtype = TYCHAR;
  366.         out_const(outfile, &cb);
  367.         frexpr(cb.vleng);
  368.         nice_printf(outfile, " };\n");
  369.         nice_printf(outfile, "#define %s %s_st.val\n", litname, litname);
  370.         continue;
  371.         }
  372.     nice_printf(outfile, "static %s %s = ",
  373.         c_type_decl(litp->littype,0), litname);
  374.  
  375.     t = litp->littype;
  376.     if (ONEOF(t, MSKREAL|MSKCOMPLEX)) {
  377.         cb.vstg = 1;
  378.         cb.Const.cds[0] = litp->cds[0];
  379.         cb.Const.cds[1] = litp->cds[1];
  380.         }
  381.     else {
  382.         memcpy((char *)&cb.Const, (char *)&litp->litval,
  383.             sizeof(cb.Const));
  384.         cb.vstg = 0;
  385.         }
  386.     out_const(outfile, &cb);
  387.  
  388.     nice_printf (outfile, ";\n");
  389.     } /* for */
  390.     if (did_one)
  391.         nice_printf (outfile, "\n");
  392. } /* wr_globals */
  393.  
  394.  ftnint
  395. #ifdef KR_headers
  396. commlen(vl)
  397.     register chainp vl;
  398. #else
  399. commlen(register chainp vl)
  400. #endif
  401. {
  402.     ftnint size;
  403.     int type;
  404.     struct Dimblock *t;
  405.     Namep v;
  406.  
  407.     while(vl->nextp)
  408.         vl = vl->nextp;
  409.     v = (Namep)vl->datap;
  410.     type = v->vtype;
  411.     if (type == TYCHAR)
  412.         size = v->vleng->constblock.Const.ci;
  413.     else
  414.         size = typesize[type];
  415.     if ((t = v->vdim) && ISCONST(t->nelt))
  416.         size *= t->nelt->constblock.Const.ci;
  417.     return size + v->voffset;
  418.     }
  419.  
  420.  static void    /* Pad common block if an EQUIVALENCE extended it. */
  421. #ifdef KR_headers
  422. pad_common(c)
  423.     Extsym *c;
  424. #else
  425. pad_common(Extsym *c)
  426. #endif
  427. {
  428.     register chainp cvl;
  429.     register Namep v;
  430.     long L = c->maxleng;
  431.     int type;
  432.     struct Dimblock *t;
  433.     int szshort = typesize[TYSHORT];
  434.  
  435.     for(cvl = c->allextp; cvl; cvl = cvl->nextp)
  436.         if (commlen((chainp)cvl->datap) >= L)
  437.             return;
  438.     v = ALLOC(Nameblock);
  439.     v->vtype = type = L % szshort ? TYCHAR
  440.                       : type_choice[L/szshort % 4];
  441.     v->vstg = STGCOMMON;
  442.     v->vclass = CLVAR;
  443.     v->tag = TNAME;
  444.     v->vdim = t = ALLOC(Dimblock);
  445.     t->ndim = 1;
  446.     t->dims[0].dimsize = ICON(L / typesize[type]);
  447.     v->fvarname = v->cvarname = "eqv_pad";
  448.     if (type == TYCHAR)
  449.         v->vleng = ICON(1);
  450.     c->allextp = mkchain((char *)mkchain((char *)v, CHNULL), c->allextp);
  451.     }
  452.  
  453.  
  454. /* wr_common_decls -- outputs the common declarations in one of three
  455.    formats.  If all references to a common block look the same (field
  456.    names and types agree), only one actual declaration will appear.
  457.    Otherwise, the same block will require many structs.  If there is no
  458.    block data, these structs will be union'ed together (so the linker
  459.    knows the size of the largest one).  If there IS a block data, only
  460.    that version will be associated with the variable, others will only be
  461.    defined as types, so the pointer can be cast to it.  e.g.
  462.  
  463.     FORTRAN                C
  464. ----------------------------------------------------------------------
  465.     common /com1/ a, b, c        struct { real a, b, c; } com1_;
  466.  
  467.     common /com1/ a, b, c        union {
  468.     common /com1/ i, j, k            struct { real a, b, c; } _1;
  469.                         struct { integer i, j, k; } _2;
  470.                     } com1_;
  471.  
  472.     common /com1/ a, b, c        struct com1_1_ { real a, b, c; };
  473.     block data            struct { integer i, j, k; } com1_ =
  474.     common /com1/ i, j, k          { 1, 2, 3 };
  475.     data i/1/, j/2/, k/3/
  476.  
  477.  
  478.    All of these versions will be followed by #defines, since the code in
  479.    the function bodies can't know ahead of time which of these options
  480.    will be taken */
  481.  
  482. /* Macros for deciding the output type */
  483.  
  484. #define ONE_STRUCT 1
  485. #define UNION_STRUCT 2
  486. #define INIT_STRUCT 3
  487.  
  488.  void
  489. #ifdef KR_headers
  490. wr_common_decls(outfile)
  491.     FILE *outfile;
  492. #else
  493. wr_common_decls(FILE *outfile)
  494. #endif
  495. {
  496.     Extsym *ext;
  497.     extern int extcomm;
  498.     static char *Extern[4] = {"", "Extern ", "extern "};
  499.     char *E, *E0 = Extern[extcomm];
  500.     int did_one = 0;
  501.  
  502.     for (ext = extsymtab; ext < nextext; ext++) {
  503.     if (ext -> extstg == STGCOMMON && ext->allextp) {
  504.         chainp comm;
  505.         int count = 1;
  506.         int which;            /* which display to use;
  507.                        ONE_STRUCT, UNION or INIT */
  508.  
  509.         if (!did_one)
  510.         nice_printf (outfile, "/* Common Block Declarations */\n\n");
  511.  
  512.         pad_common(ext);
  513.  
  514. /* Construct the proper, condensed list of structs; eliminate duplicates
  515.    from the initial list   ext -> allextp   */
  516.  
  517.         comm = ext->allextp = revchain(ext->allextp);
  518.  
  519.         if (ext -> extinit)
  520.         which = INIT_STRUCT;
  521.         else if (comm->nextp) {
  522.         which = UNION_STRUCT;
  523.         nice_printf (outfile, "%sunion {\n", E0);
  524.         next_tab (outfile);
  525.         E = "";
  526.         }
  527.         else {
  528.         which = ONE_STRUCT;
  529.         E = E0;
  530.         }
  531.  
  532.         for (; comm; comm = comm -> nextp, count++) {
  533.  
  534.         if (which == INIT_STRUCT)
  535.             nice_printf (outfile, "struct %s%d_ {\n",
  536.                 ext->cextname, count);
  537.         else
  538.             nice_printf (outfile, "%sstruct {\n", E);
  539.  
  540.         next_tab (c_file);
  541.  
  542.         wr_struct (outfile, (chainp) comm -> datap);
  543.  
  544.         prev_tab (c_file);
  545.         if (which == UNION_STRUCT)
  546.             nice_printf (outfile, "} _%d;\n", count);
  547.         else if (which == ONE_STRUCT)
  548.             nice_printf (outfile, "} %s;\n", ext->cextname);
  549.         else
  550.             nice_printf (outfile, "};\n");
  551.         } /* for */
  552.  
  553.         if (which == UNION_STRUCT) {
  554.         prev_tab (c_file);
  555.         nice_printf (outfile, "} %s;\n", ext->cextname);
  556.         } /* if */
  557.         did_one = 1;
  558.         nice_printf (outfile, "\n");
  559.  
  560.         for (count = 1, comm = ext -> allextp; comm;
  561.             comm = comm -> nextp, count++) {
  562.         def_start(outfile, ext->cextname,
  563.             comm_union_name(count), "");
  564.         switch (which) {
  565.             case ONE_STRUCT:
  566.                 extern_out (outfile, ext);
  567.                 break;
  568.             case UNION_STRUCT:
  569.                 nice_printf (outfile, "(");
  570.             extern_out (outfile, ext);
  571.             nice_printf(outfile, "._%d)", count);
  572.                 break;
  573.             case INIT_STRUCT:
  574.             nice_printf (outfile, "(*(struct ");
  575.             extern_out (outfile, ext);
  576.             nice_printf (outfile, "%d_ *) &", count);
  577.             extern_out (outfile, ext);
  578.             nice_printf (outfile, ")");
  579.                 break;
  580.         } /* switch */
  581.         nice_printf (outfile, "\n");
  582.         } /* for count = 1, comm = ext -> allextp */
  583.         nice_printf (outfile, "\n");
  584.     } /* if ext -> extstg == STGCOMMON */
  585.     } /* for ext = extsymtab */
  586. } /* wr_common_decls */
  587.  
  588.  void
  589. #ifdef KR_headers
  590. wr_struct(outfile, var_list)
  591.     FILE *outfile;
  592.     chainp var_list;
  593. #else
  594. wr_struct(FILE *outfile, chainp var_list)
  595. #endif
  596. {
  597.     int last_type = -1;
  598.     int did_one = 0;
  599.     chainp this_var;
  600.  
  601.     for (this_var = var_list; this_var; this_var = this_var -> nextp) {
  602.     Namep var = (Namep) this_var -> datap;
  603.     int type;
  604.     char *comment = NULL;
  605.  
  606.     if (var == (Namep) NULL)
  607.         err ("wr_struct:  null variable");
  608.     else if (var -> tag != TNAME)
  609.         erri ("wr_struct:  bad tag on variable '%d'",
  610.             var -> tag);
  611.  
  612.     type = var -> vtype;
  613.  
  614.     if (last_type == type && did_one)
  615.         nice_printf (outfile, ", ");
  616.     else {
  617.         if (did_one)
  618.         nice_printf (outfile, ";\n");
  619.         nice_printf (outfile, "%s ",
  620.             c_type_decl (type, var -> vclass == CLPROC));
  621.     } /* else */
  622.  
  623. /* Character type is really a string type.  Put out a '*' for parameters
  624.    with unknown length and functions returning character */
  625.  
  626.     if (var -> vtype == TYCHAR && (!ISICON ((var -> vleng))
  627.         || var -> vclass == CLPROC))
  628.         nice_printf (outfile, "*");
  629.  
  630.     var -> vstg = STGAUTO;
  631.     out_name (outfile, var);
  632.     if (var -> vclass == CLPROC)
  633.         nice_printf (outfile, "()");
  634.     else if (var -> vdim)
  635.         comment = wr_ardecls(outfile, var->vdim,
  636.                 var->vtype == TYCHAR && ISICON(var->vleng)
  637.                 ? var->vleng->constblock.Const.ci : 1L);
  638.     else if (var -> vtype == TYCHAR && var -> vclass != CLPROC &&
  639.         ISICON ((var -> vleng)))
  640.         nice_printf (outfile, "[%ld]",
  641.             var -> vleng -> constblock.Const.ci);
  642.  
  643.     if (comment)
  644.         nice_printf (outfile, "%s", comment);
  645.     did_one = 1;
  646.     last_type = type;
  647.     } /* for this_var */
  648.  
  649.     if (did_one)
  650.     nice_printf (outfile, ";\n");
  651. } /* wr_struct */
  652.  
  653.  
  654.  char *
  655. #ifdef KR_headers
  656. user_label(stateno)
  657.     ftnint stateno;
  658. #else
  659. user_label(ftnint stateno)
  660. #endif
  661. {
  662.     static char buf[USER_LABEL_MAX + 1];
  663.     static char *Lfmt[2] = { "L_%ld", "L%ld" };
  664.  
  665.     if (stateno >= 0)
  666.         sprintf(buf, Lfmt[shiftcase], stateno);
  667.     else
  668.         sprintf(buf, "L_%s", extsymtab[-1-stateno].fextname);
  669.     return buf;
  670. } /* user_label */
  671.  
  672.  
  673.  char *
  674. #ifdef KR_headers
  675. temp_name(starter, num, storage)
  676.     char *starter;
  677.     int num;
  678.     char *storage;
  679. #else
  680. temp_name(char *starter, int num, char *storage)
  681. #endif
  682. {
  683.     static char buf[IDENT_LEN];
  684.     char *pointer = buf;
  685.     char *prefix = "t";
  686.  
  687.     if (storage)
  688.     pointer = storage;
  689.  
  690.     if (starter && *starter)
  691.     prefix = starter;
  692.  
  693.     sprintf (pointer, "%s__%d", prefix, num);
  694.     return pointer;
  695. } /* temp_name */
  696.  
  697.  
  698.  char *
  699. #ifdef KR_headers
  700. equiv_name(memno, store)
  701.     int memno;
  702.     char *store;
  703. #else
  704. equiv_name(int memno, char *store)
  705. #endif
  706. {
  707.     static char buf[IDENT_LEN];
  708.     char *pointer = buf;
  709.  
  710.     if (store)
  711.     pointer = store;
  712.  
  713.     sprintf (pointer, "%s_%d", EQUIV_INIT_NAME, memno);
  714.     return pointer;
  715. } /* equiv_name */
  716.  
  717.  void
  718. #ifdef KR_headers
  719. def_commons(of)
  720.     FILE *of;
  721. #else
  722. def_commons(FILE *of)
  723. #endif
  724. {
  725.     Extsym *ext;
  726.     int c, onefile, Union;
  727.     chainp comm;
  728.     extern int ext1comm;
  729.     FILE *c_filesave = c_file;
  730.  
  731.     if (ext1comm == 1) {
  732.         onefile = 1;
  733.         c_file = of;
  734.         fprintf(of, "/*>>>'/dev/null'<<<*/\n\
  735. #ifdef Define_COMMONs\n\
  736. /*<<</dev/null>>>*/\n");
  737.         }
  738.     else
  739.         onefile = 0;
  740.     for(ext = extsymtab; ext < nextext; ext++)
  741.         if (ext->extstg == STGCOMMON
  742.         && !ext->extinit && (comm = ext->allextp)) {
  743.             sprintf(outbtail, "%scom.c", ext->cextname);
  744.             if (onefile)
  745.                 fprintf(of, "/*>>>'%s'<<<*/\n",
  746.                     outbtail);
  747.             else {
  748.                 c_file = of = fopen(outbuf,textwrite);
  749.                 if (!of)
  750.                     fatalstr("can't open %s", outbuf);
  751.                 }
  752.             fprintf(of, "#include \"f2c.h\"\n");
  753.             if (Ansi == 2)
  754.                 fprintf(of,
  755.              "\n#ifdef __cplusplus\nextern \"C\" {\n#endif\n\n");
  756.             if (comm->nextp) {
  757.                 Union = 1;
  758.                 nice_printf(of, "union {\n");
  759.                 next_tab(of);
  760.                 }
  761.             else
  762.                 Union = 0;
  763.             for(c = 1; comm; comm = comm->nextp) {
  764.                 nice_printf(of, "struct {\n");
  765.                 next_tab(of);
  766.                 wr_struct(of, (chainp)comm->datap);
  767.                 prev_tab(of);
  768.                 if (Union)
  769.                     nice_printf(of, "} _%d;\n", c++);
  770.                 }
  771.             if (Union)
  772.                 prev_tab(of);
  773.             nice_printf(of, "} %s;\n", ext->cextname);
  774.             if (Ansi == 2)
  775.                 fprintf(of,
  776.              "\n#ifdef __cplusplus\n}\n#endif\n");
  777.             if (onefile)
  778.                 fprintf(of, "/*<<<%s>>>*/\n", outbtail);
  779.             else
  780.                 fclose(of);
  781.             }
  782.     if (onefile)
  783.         fprintf(of, "/*>>>'/dev/null'<<<*/\n#endif\n\
  784. /*<<</dev/null>>>*/\n");
  785.     c_file = c_filesave;
  786.     }
  787.  
  788. /* C Language keywords.  Needed to filter unwanted fortran identifiers like
  789.  * "int", etc.  Source:  Kernighan & Ritchie, eds. 1 and 2; Stroustrup.
  790.  * Also includes C++ keywords and types used for I/O in f2c.h .
  791.  * These keywords must be in alphabetical order (as defined by strcmp()).
  792.  */
  793.  
  794. char *c_keywords[] = {
  795.     "Long", "Multitype", "Namelist", "Vardesc", "abs", "acos",
  796.     "addr", "address", "aerr", "alist", "asin", "asm", "atan",
  797.     "atan2", "aunit", "auto", "break", "c", "case", "catch", "cerr",
  798.     "char", "ciend", "cierr", "cifmt", "cilist", "cirec", "ciunit",
  799.     "class", "cllist", "complex", "const", "continue", "cos",
  800.     "cosh", "csta", "cunit", "d", "dabs", "default", "defined",
  801.     "delete", "dims", "dmax", "dmin", "do", "double",
  802.     "doublecomplex", "doublereal", "else", "entry", "enum", "exp",
  803.     "extern", "far", "flag", "float", "for", "friend", "ftnint",
  804.     "ftnlen", "goto", "h", "huge", "i", "iciend", "icierr",
  805.     "icifmt", "icilist", "icirlen", "icirnum", "iciunit", "if",
  806.     "inacc", "inacclen", "inblank", "inblanklen", "include",
  807.     "indir", "indirlen", "inerr", "inex", "infile", "infilen",
  808.     "infmt", "infmtlen", "inform", "informlen", "inline", "inlist",
  809.     "inname", "innamed", "innamlen", "innrec", "innum", "inopen",
  810.     "inrecl", "inseq", "inseqlen", "int", "integer", "integer1",
  811.     "inunf", "inunflen", "inunit", "log", "logical", "logical1",
  812.     "long", "longint", "max", "min", "name", "near", "new", "nvars",
  813.     "oacc", "oblnk", "oerr", "ofm", "ofnm", "ofnmlen", "olist",
  814.     "operator", "orl", "osta", "ounit", "overload", "private",
  815.     "protected", "public", "r", "real", "register", "return",
  816.     "short", "shortint", "shortlogical", "signed", "sin", "sinh",
  817.     "sizeof", "sqrt", "static", "struct", "switch", "tan", "tanh",
  818.     "template", "this", "try", "type", "typedef", "union",
  819.     "unsigned", "vars", "virtual", "void", "volatile", "while", "z"
  820.     }; /* c_keywords */
  821.  
  822. int n_keywords = sizeof(c_keywords)/sizeof(char *);
  823.